package Data::Conveyor::Ticket::Payload;
# ptags: DCTP

# $Id: Payload.pm 13653 2007-10-22 09:11:20Z gr $
#
# This class houses the ticket payload objects

use warnings;
use strict;
use Error::Hierarchy::Util 'assert_defined';


our $VERSION = '0.02';


use base qw(
    Class::Scaffold::Storable
    Class::Scaffold::HierarchicalDirty
);


__PACKAGE__
    ->mk_framework_object_accessors(payload_common => 'common')
    ->mk_framework_object_array_accessors(
        payload_transaction => 'transactions',
        payload_lock        => 'locks',
    );



# Generate add_* methods for each payload item. The method can be called in
# various ways:
#
# 1) Without any arguments: will push a new and empty payload item into the
# according payload item list.
#
# 2) With an payload item data object (eg. a Registry::Person) as first
# argument: will push the given object into the according payload item list.
#
# 3) With any number of arguments of which the first one isn't a reference:
# will create a new payload item with given arguments passed to the
# constructor. This item is pushed into the according payload item list.

sub generate_add_method {
    my ($self, $object_type, $method, $payload_object_type, $push_method) = @_;

    # FIXME: these PTAGS aren't going to work, as the methods are only
    # generated when the application is really running, not when ptags
    # loads the module.

    no strict 'refs';

    $::PTAGS && printf "%s\t%s\t%s\n", $method, __FILE__, __LINE__ + 1;
    *$method = sub {
        my $self = shift;
        my $payload_object = $self->delegate->make_obj($payload_object_type);

        # If at least one argument is given, check if it's a reference. If
        # it is, use it as our object to set, Otherwise create a new
        # payload item supplying all the arguments we might have gotten.

        my $object = defined $_[0] && ref $_[0]
            ? $_[0]
            : $self->delegate->make_obj($object_type, @_);

        $payload_object->$object_type($object);
        $self->$push_method($payload_object);
        return $payload_object;
    }
}


sub init {
    my $self = shift;
    $self->SUPER::init(@_);

    our $did_generate_methods;
    return if $did_generate_methods++;

    for my $object_type ($self->delegate->OT) {

        my $add_method          = sprintf("add_%s", $object_type);
        my $add_unique_method   = sprintf("add_unique_%s", $object_type);
        my $payload_object_type = sprintf("payload_%s", $object_type);
        my $push_method         = sprintf("%ss_push", $object_type);
        my $set_push_method     = sprintf("%ss_set_push", $object_type);

        $self->generate_add_method($object_type, $add_method,
            $payload_object_type, $push_method);
        $self->generate_add_method($object_type, $add_unique_method,
            $payload_object_type, $set_push_method);
    }
}


sub LIST_ACCESSOR_FOR_OBJECT_TYPE {
    local $_ = $_[0]->delegate;
    (
        $_->OT_LOCK         => 'locks',
        $_->OT_TRANSACTION  => 'transactions',
    )
}


sub get_list_name_for_object_type {
    my ($self, $object_type) = @_;
    my $list_accessor = $self->every_hash('LIST_ACCESSOR_FOR_OBJECT_TYPE');
    assert_defined my $method = $list_accessor->{$object_type},
        "unknown payload object type [$object_type]";
    $method;
}


sub get_list_for_object_type {
    my ($self, $object_type) = @_;
    my $method = $self->get_list_name_for_object_type($object_type);
    $self->$method;
}


sub get_transactions_with_data_object_type {
    my ($self, $object_type) = @_;
    grep { $_->data->object_type eq $object_type } $self->transactions;
}


sub get_transactions_with_data_object_type_and_cmd {
    my ($self, $object_type, $cmd) = @_;
    grep { $_->data->command eq $cmd }
    $self->get_transactions_with_data_object_type($object_type);
}


sub check {
    my ($self, $ticket) = @_;

    # check object limits; also check the payload items while we're at it

    for my $object_type ($self->delegate->OT) {
        my $limit = $self->delegate->
            get_object_limit($ticket->type, $object_type);
        my $index;
        for my $item ($self->get_list_for_object_type($object_type)) {
            $index++;

            # Ask the business object to check itself, accumulating exceptions
            # into the business object's exception container.

            $item->check($ticket);
            next if $index <= $limit;

            $item->exception_container->record(
                'Data::Conveyor::Exception::ObjectLimitExceeded',
                ticket_type => $ticket->type,
                object_type => $object_type,
                limit       => $limit,
            );
        }
    }
    $self->common->check($ticket);
}


# determines the overall payload rc

sub rc {
    my ($self, $ticket) = @_;

    # Start with RC_OK; if a stage wants to use another default rc, it can do
    # so by setting the common payload item's default_rc.

    my $rc = $self->delegate->make_obj('value_ticket_rc', 
        $self->delegate->RC_OK) + $self->common->rc($ticket);

    for my $object_type ($self->delegate->OT) {
        $rc += $_->rc($ticket) for
            $self->get_list_for_object_type($object_type);
    }
    $rc;
}


# determines the overall payload status

sub status {
    my ($self, $ticket) = @_;

    # Start with TS_RUNNING; if a stage wants to use another default status,
    # it can do so by setting the common payload item's default_status.

    my $status = $self->delegate->make_obj('value_ticket_status', 
        $self->delegate->TS_RUNNING) + $self->common->status($ticket);

    for my $object_type ($self->delegate->OT) {
        $status += $_->status($ticket) for
            $self->get_list_for_object_type($object_type);
    }
    $status;
}


sub update_transaction_stati {
    my ($self, $ticket) = @_;
    $_->transaction->update_status($ticket) for $self->transactions;
}


sub filter_exceptions_by_rc {
    my ($self, $ticket, @filter) = @_;
    my $result = $self->delegate->make_obj('exception_container');
    for my $object_type ($self->delegate->OT) {
        for my $payload_item ($self->get_list_for_object_type($object_type)) {
            $result->items_push($payload_item->exception_container->
                filter_exceptions_by_rc($ticket, @filter));
        }
    }
    $result->items_push($self->common->exception_container->
        filter_exceptions_by_rc($ticket, @filter));
    $result;
}


sub filter_exceptions_by_status {
    my ($self, $ticket, @filter) = @_;
    my $result = $self->delegate->make_obj('exception_container');
    for my $object_type ($self->delegate->OT) {
        for my $payload_item ($self->get_list_for_object_type($object_type)) {
            $result->items_push($payload_item->exception_container->
                filter_exceptions_by_status($ticket, @filter));
        }
    }
    $result->items_push($self->common->exception_container->
        filter_exceptions_by_status($ticket, @filter));
    $result;
}


sub get_all_exceptions {
    my $self = shift;
    my $result = $self->delegate->make_obj('exception_container');
    for my $object_type ($self->delegate->OT) {
        for my $payload_item ($self->get_list_for_object_type($object_type)) {
            $result->items_push($payload_item->exception_container->items);
        }
    }
    $result->items_push($self->common->exception_container->items);
    $result;
}


sub clear_all_exceptions {
    my $self = shift;
    for my $object_type ($self->delegate->OT) {
        for my $payload_item ($self->get_list_for_object_type($object_type)) {
            $payload_item->exception_container->clear_items;
        }
    }
}


# Iterates over all payload items and deletes all exceptions whose uuid is one
# of those given in the argument list

sub delete_exceptions_by_uuid {
    my ($self, @uuid) = @_;
    for my $object_type ($self->delegate->OT) {
        for my $payload_item ($self->get_list_for_object_type($object_type)) {
            $payload_item->exception_container->delete_by_uuid(@uuid);
        }
    }
}


sub delete_implicit_items {
    my $self = shift;
    for my $object_type ($self->delegate->OT) {
        my $list_name = $self->get_list_name_for_object_type($object_type);
        $self->$list_name([ grep { !$_->implicit } $self->$list_name ]);
    }
}


sub prepare_comparable {
    my $self = shift;
    $self->SUPER::prepare_comparable(@_);

    # Touch various accessors that will autovivify hash keys so we can be sure
    # they exist, which is a kind of normalization for the purpose of
    # comparing two objects of this class.

    $self->common;
    $self->transactions;
    $self->locks;

    # Touch the items of all exception containers so comparsions work (if the
    # ticket is stored, the items of all exception containers at least exist).

    $self->get_all_exceptions;

    for my $object_type ($self->delegate->OT) {
        my $list_name = $self->get_list_name_for_object_type($object_type);
        $self->$list_name;
    }
}


sub apply_instruction_containers {
    my $self = shift;
    for my $object_type ($self->delegate->OT) {
        for my $payload_item ($self->get_list_for_object_type($object_type)) {
            $payload_item->apply_instruction_container;
        }
    }
}


1;


__END__

{% USE p = PodGenerated %}

=head1 NAME

{% p.package %} - stage-based conveyor-belt-like ticket handling system

=head1 SYNOPSIS

    {% p.package %}->new;

=head1 DESCRIPTION

None yet. This is an early release; fully functional, but undocumented. The
next release will have more documentation.

=head1 METHODS

=over 4

{% p.write_methods %}

=back

{% p.write_inheritance %}

{% PROCESS standard_pod %}

=cut

